home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / gcl-1.000 / gcl-1 / gcl-1.0 / lsp / assert.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1994-05-07  |  8.0 KB  |  217 lines
  1. ;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa
  2.  
  3. ;; This file is part of GNU Common Lisp, herein referred to as GCL
  4. ;;
  5. ;; GCL is free software; you can redistribute it and/or modify it under
  6. ;;  the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by
  7. ;; the Free Software Foundation; either version 2, or (at your option)
  8. ;; any later version.
  9. ;; 
  10. ;; GCL is distributed in the hope that it will be useful, but WITHOUT
  11. ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  12. ;; FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Library General Public 
  13. ;; License for more details.
  14. ;; 
  15. ;; You should have received a copy of the GNU Library General Public License 
  16. ;; along with GCL; see the file COPYING.  If not, write to the Free Software
  17. ;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  18.  
  19.  
  20. ;;;;    assert.lsp
  21.  
  22.  
  23. (in-package 'lisp)
  24.  
  25.  
  26. (export '(check-type assert
  27.           ecase ccase typecase etypecase ctypecase))
  28.  
  29.  
  30. (in-package 'system)
  31.  
  32.  
  33. (proclaim '(optimize (safety 2) (space 3)))
  34.  
  35.  
  36. (defmacro check-type (place typespec &optional (string nil s))
  37.   `(do ((*print-level* 4)
  38.         (*print-length* 4))
  39.        ((typep ,place ',typespec) nil)
  40.        (cerror ""
  41.                "The value of ~:@(~S~), ~:@(~S~), is not ~A."
  42.                ',place ,place
  43.                ,(if s string `',typespec))
  44.        ,(ask-for-form place)
  45.        (format *error-output* "Now continuing ...~%")))
  46.  
  47.  
  48. (defmacro assert (test-form &optional places string &rest args)
  49.   `(do ((*print-level* 4)
  50.         (*print-length* 4))
  51.        (,test-form nil)
  52.        ,(if string
  53.             `(cerror "" ,string ,@args)
  54.             `(cerror "" "The assertion ~:@(~S~) is failed." ',test-form))
  55.        ,@(mapcar #'ask-for-form places)
  56.        (format *error-output* "Now continuing ...~%")))
  57.  
  58.  
  59. (defun ask-for-form (place)
  60.   `(progn (format  *error-output*
  61.                    "Please input the new value for the place ~:@(~S~): "
  62.                    ',place)
  63.           (finish-output *error-output*)
  64.           (setf ,place (read))))
  65.  
  66.  
  67. (defmacro ecase (keyform &rest clauses &aux (key (gensym)))
  68.    (do ((l (reverse clauses) (cdr l))
  69.         (form `(let ((*print-level* 4)
  70.                      (*print-length* 4))
  71.                  (error
  72.                   "The value of ~:@(~S~), ~:@(~S~), is ~
  73.                   ~#[nonsense~;not ~:@(~S~)~;neither ~:@(~S~) nor ~:@(~S~)~
  74.                   ~:;not ~@{~#[~;or ~]~:@(~S~)~^, ~}~]."
  75.                   ',keyform
  76.                   ,key
  77.                   ,@(mapcan #'(lambda (x)
  78.                                 (if (listp (car x))
  79.                                     (mapcar #'(lambda (y) `',y) (car x))
  80.                                     `(',(car x))))
  81.                             clauses)))))
  82.        ((endp l) `(let ((,key ,keyform)) ,form))
  83.        (when (caar l)
  84.              (setq form `(if ,(if (listp (caar l))
  85.                                   `(member ,key ',(caar l))
  86.                                   `(eql ,key ',(caar l)))
  87.                              (progn ,@(cdar l))
  88.                              ,form))))
  89. )
  90.  
  91. (defmacro ccase (keyplace &rest clauses &aux (key (gensym)))
  92.    `(loop (let ((,key ,keyplace))
  93.                ,@(mapcar #'(lambda (l)
  94.                                   `(when ,(if (listp (car l))
  95.                                               `(member ,key ',(car l))
  96.                                               `(eql ,key ',(car l)))
  97.                                          (return (progn ,@(cdr l)))))
  98.                          clauses)
  99.                (let ((*print-level* 4)
  100.                      (*print-length* 4))
  101.                     (cerror ""
  102.                             "The value of ~:@(~S~), ~:@(~S~), is ~
  103.                              ~#[nonsense~;not ~:@(~S~)~;neither ~
  104.                              ~:@(~S~) nor ~:@(~S~)~
  105.                              ~:;not ~@{~#[~;or ~]~:@(~S~)~^, ~}~]."
  106.                              ',keyplace
  107.                              ,key
  108.                              ,@(mapcan
  109.                                 #'(lambda (x)
  110.                                          (if (listp (car x))
  111.                                              (mapcar #'(lambda (y) `',y)
  112.                                                      (car x))
  113.                                              `(',(car x))))
  114.                                 clauses))
  115.                     ,(ask-for-form keyplace)
  116.                     (format *error-output* "Now continuing ...~%"))))
  117.    )
  118.  
  119. (defmacro typecase (keyform &rest clauses)
  120.   (do ((l (reverse clauses) (cdr l))
  121.        (form nil) (key (gensym)))
  122.       ((endp l) `(let ((,key ,keyform)) ,form))
  123.       (if (or (eq (caar l) 't) (eq (caar l) 'otherwise))
  124.           (setq form `(progn ,@(cdar l)))
  125.           (setq form
  126.                 `(if (typep ,key (quote ,(caar l)))
  127.                      (progn ,@(cdar l))
  128.                      ,form))))
  129.   )
  130.  
  131. (defmacro etypecase (keyform &rest clauses &aux (key (gensym)))
  132.    (do ((l (reverse clauses) (cdr l))
  133.         (form `(error (typecase-error-string
  134.                        ',keyform ,key
  135.                        ',(mapcar #'(lambda (l) (car l)) clauses)))))
  136.        ((endp l) `(let ((,key ,keyform)) ,form))
  137.        (setq form `(if (typep ,key ',(caar l))
  138.                        (progn ,@(cdar l))
  139.                        ,form))
  140.        )
  141.    )
  142.  
  143. (defmacro ctypecase (keyplace &rest clauses &aux (key (gensym)))
  144.   `(loop (let ((,key ,keyplace))
  145.               ,@(mapcar #'(lambda (l)
  146.                                  `(when (typep ,key ',(car l))
  147.                                         (return (progn ,@(cdr l)))))
  148.                         clauses)
  149.               (cerror ""
  150.                       (typecase-error-string
  151.                        ',keyplace ,key
  152.                        ',(mapcar #'(lambda (l) (car l)) clauses))))
  153.          ,(ask-for-form keyplace)
  154.          (format *error-output* "Now continuing ...~%")))
  155.   )
  156.  
  157. (defun typecase-error-string
  158.        (keyform keyvalue negs
  159.                 &aux (negs1 nil) (poss nil) (poss1 nil))
  160.    (do ()
  161.        ((endp negs))
  162.        (if (symbolp (car negs))
  163.            (progn (push (list (car negs)) negs1) (pop negs))
  164.            (case (caar negs)
  165.                  (or (setq negs (append (cdar negs) (cdr negs))))
  166.                  (member (mapc #'(lambda (x) (push `(member ,x) negs1))
  167.                                (cdar negs))
  168.                          (pop negs))
  169.                  (not (push (cadar negs) poss) (pop negs))
  170.                  (otherwise (push (car negs) negs1) (pop negs)))))
  171.    (do ()
  172.        ((endp poss))
  173.        (cond ((symbolp (car poss)) (push (list (car poss)) poss1) (pop poss))
  174.              ((eq (caar poss) 'and)
  175.               (setq poss (append (cdar poss) (cdr poss))))
  176.              (t (push (car poss) poss1) (pop poss))))
  177.    (format
  178.     nil
  179.     "The value of ~:@(~S~), ~:@(~S~), is ~?~?."
  180.     keyform
  181.     keyvalue
  182.     "~#[~;~;~?~;~;~? and ~?~:;~%~@{~#[~;~;and ~]~?~^, ~}~]"
  183.     (mapcan 'typecase-error-strings poss1)
  184.     "~:[~[something~;~:;~%~]~;~[~:;, but~%~]~]~
  185.      ~#[~;~;not ~?~;~;neither ~? nor ~?~:;not ~@{~#[~;~;or ~]~?~^, ~}~]"
  186.     (cons poss1 (cons (length negs1)
  187.                       (mapcan 'typecase-error-strings (reverse negs1))))
  188.     )
  189.    )
  190.  
  191. (defun typecase-error-strings (type)
  192.  (cond ((eq (car type) 'member)
  193.         (case (length (cdr type))
  194.               (0 `("one of none" nil))
  195.               (1 `("~:@(~S~)" (,(cadr type))))
  196.               (2 `("either ~:@(~S~) or ~:@(~S~)" ,(cdr type)))
  197.               (t `("one of ~:@(~S~)" (,(cdr type))))))
  198.        ((eq (car type) 'satisfies)
  199.         `("an object satisfying ~:@(~S~)" ,(cdr type)))
  200.        ((or (endp (cdr type)) (null (remove '* (cdr type))))
  201.         (let ((x (assoc (car type)
  202.                         '((t "anything")
  203.                           (nil "none")
  204.                           (null "nil")
  205.                           (common "an object of a standard data type")))))
  206.              (if x
  207.                  `(,(cadr x) nil)
  208.                  `("~:[a~;an~] ~(~A~)" (,(boin-p (car type)) ,(car type))))))
  209.        (t `("~:[a~;an~] ~:@(~S~)" (,(boin-p (car type)) ,type))))
  210.  )
  211.  
  212. (defun boin-p (symbol)
  213.        (member (elt (symbol-name symbol) 0)
  214.                '(#\A #\I #\U #\E #\O #\a #\i #\u #\e #\o))
  215. )
  216.  
  217.